perm filename BRAKE.14[AID,LSP]1 blob
sn#418532 filedate 1979-02-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DECLARE (*FEXPR BRAKE UNBRAKE %DATA-INIT)
C00012 ENDMK
C⊗;
(DECLARE (*FEXPR BRAKE UNBRAKE %DATA-INIT)
(SPECIAL %TOP-EDIT-EXP %#CE W %BROKEN-FNS% %single-broken%))
(DEFUN %IOG% MACRO (X)
;; simulates the losing IOG function.
;; actually simulates Finin's losing IOG simulator
(PROG (↑CHAR LIST-OF-TS TEMP)
(DO ((CH (EXPLODE (CADR X)) (CDR CH)))
((NULL CH))
(SETQ TEMP (ASSQ (CAR CH)
'((V W NIL) (W W T) (R R T) (T R NIL) (Q Q T) (S Q NIL))))
(OR TEMP (ERROR '|Nasty losing IOG error| (CAR CH)))
(PUSH (IMPLODE (LIST '↑ (CADR TEMP))) ↑CHAR)
(PUSH (CADDR TEMP) LIST-OF-TS))
(RETURN (CONS (CONS 'LAMBDA (CONS ↑CHAR (CDDR X)))
LIST-OF-TS))))
(EVAL-WHEN (LOAD EVAL COMPILE)
(COND ((STATUS FEATURES NEWIO)
(DEFUN VERSION MACRO (X)
(list 'quote (caddr (namelist infile)))))
(T (DEFUN VERSION MACRO (X)(LIST 'QUOTE (CADR (STATUS UREAD)))))))
(DEFUN %BRAKE-LOAD-MSG NIL
(OR (STATUS FEATURE NOLDMSG)
((LAMBDA(↑R)
(TERPRI)
(PRINC '|;loading BRAKE.|)
(PRINC (VERSION))
(PRINC '| |)
(TERPRI))
NIL)))
(%BRAKE-LOAD-MSG)
(SETQ %BROKEN-FNS% NIL %single-broken% nil)
;;; Brakes multiple functions
(defun brk fexpr (forms)
(append (mapcar (function (lambda (q) (brk1 q t))) forms) '(broken)))
(defun brakeif fexpr (forms)
(apply 'brk1 forms)
(list (car forms) 'broken))
(defun brk1 (form pred)
(prog (type lam)
(cond ((setq lam (get form 'expr))(setq type 'expr))
((setq lam (get form 'fexpr))(setq type 'fexpr))
(t (princ '|Huh?|)(terpri)(return 'nothing)))
((lambda (place)
(cond ((memq form %single-broken%)
(terpri)
(princ form) (princ '| already broken!|)(terpri)
(cond ((eq (car (cadr place)) 'break))
(t (princ '|However, it's not really broken! So here goes...|)
(terpri)
(rplacd place (cons (list 'break form pred) (cdr place))))))
(t
(rplacd place (cons (list 'break form pred) (cdr place)))
(setq %single-broken% (cons form %single-broken%)))))
(cdr lam))
(return form)))
(defun unbrk fexpr (forms)
(append
(mapcar 'unbrk1 (cond (forms)
(t %single-broken%))) '(unbroken)))
(defun unbrk1 (form)
(and (memq form %single-broken%)
(prog (type lam)
(cond ((setq lam (get form 'expr))(setq type 'expr))
((setq lam (get form 'fexpr))(setq type 'fexpr))
(t (princ '|Huh?|)(terpri)(return 'nothing)))
(cond ((eq (car (caddr lam)) 'break)
(rplacd (cdr lam) (cdddr lam))
(setq %single-broken% (delete form %single-broken%))
(return form))
(t (princ '|Huh?|)(terpri)(return 'nothing))))))
(DEFUN BRAKE FEXPR (FORM)
(cond ((zerop (length form))
(append %broken-fns% %single-broken%))
((= (length form) 1) (apply 'brk form))
(t
(PROG (FUNAME NUMBER PATTERN CONDITION POSITION BREAK)
(SETQ FORM (CONS NIL FORM))
(COND ((NULL (SETQ FUNAME (OR (GET FORM 'IN)
(PROGN (SETQ FORM (CDR FORM))
(CAR FORM)))))
(SETQ FUNAME (%GETNAME %TOP-EDIT-EXP)))
(T ((LAMBDA(DRAFT)
(REMPROP FUNAME 'DRAFT)
(APPLY '%DATA-INIT (LIST FUNAME))
(PUTPROP FUNAME DRAFT 'DRAFT))
(GET FUNAME 'DRAFT))))
(SETQ NUMBER (OR (GET FORM 'NUMBER) 1.)
CONDITION (OR (GET FORM 'IF) T)
POSITION (CAR (OR (MEMBER 'AFTER FORM)
(MEMBER 'BEFORE FORM)))
PATTERN (GET FORM POSITION))
(COND ((NULL PATTERN)
(RETURN (LIST (BRK1 FUNAME CONDITION) 'BROKEN))))
(OR (MEMQ FUNAME %BROKEN-FNS%)
(SETQ %BROKEN-FNS% (CONS FUNAME %BROKEN-FNS%)))
(%EVALUATE 'TOP)
(SETQ BREAK (LIST 'BREAK
(LIST 'IN
FUNAME
POSITION
PATTERN
'NUMBER
NUMBER)
CONDITION))
(RETURN (COND ((NULL (%EVALUATE (LIST 'F
PATTERN
NUMBER)))
'WHERE??)
((ATOM PATTERN)
(%EVALUATE
(COND ((EQUAL POSITION
'AFTER)
(LIST 'AI BREAK))
((LIST 'BI BREAK))))
(%IOG% W
(SETQ ↑W T)
(%EVALUATE 'OK))
(%EVALUATE 'TOP)
(LIST FUNAME 'BROKEN))
(T (%EVALUATE (LIST 'CR
(COND ((EQUAL POSITION
'AFTER)
(LIST 'PROG2
NIL
%#CE
BREAK))
((LIST 'PROG2
BREAK
%#CE)))))
(%IOG% W
(SETQ ↑W T)
(%EVALUATE 'OK))
(%EVALUATE 'TOP)
(LIST FUNAME 'BROKEN))))))))
(defun %remdup (l)
(cond ((null l) nil)
((memq (car l) (cdr l)) (%remdup (cdr l)))
(t (cons (car l)(%remdup (cdr l))))))
(DEFUN UNBRAKE FEXPR (FORM)
(%remdup
(COND
((EQ (CAR FORM) '*) (APPEND
(MAPCAR 'UNBRAKE1 (APPEND
%SINGLE-BROKEN%
%BROKEN-FNS%))
'(UNBROKEN)))
(T (APPEND
(MAPCAR 'UNBRAKE1 (cond (FORM)
(t (append %broken-fns%
%single-broken%))))
'(UNBROKEN))) )))
(DEFUN UNBRAKE1 (FORM)
(COND ((MEMQ FORM %SINGLE-BROKEN%)(UNBRK1 FORM))
((memq form %broken-fns%)
(PROG (?FORM)
(COND (FORM (APPLY '%DATA-INIT FORM)))
(SETQ %BROKEN-FNS% (DELETE (%GETNAME %TOP-EDIT-EXP) %BROKEN-FNS%))
(%EVALUATE 'TOP)
(RETURN (DO NIL
((NULL (%EVALUATE '(F (BREAK (IN ?
?
?
NUMBER
?)
?))))
(%EVALUATE 'TOP)
(%IOG% W (SETQ ↑W T) (%EVALUATE 'OK))
(%GETNAME %TOP-EDIT-EXP))
(%EVALUATE '↑)
(COND ((OR (%MATCH '(PROG2 (BREAK ? ?) ?FORM)
%#CE)
(%MATCH '(PROG2 NIL
?FORM
(BREAK ? ?))
%#CE))
(%EVALUATE '(PR ?FORM)))
(T (%EVALUATE '(F (BREAK (IN ? ? ? NUMBER ?) ?)))
(%EVALUATE 'DELETE))))) ))
(t (princ '|Huh?|)(terpri) 'nothing)))